unit CPOpenGLPlotCanvas;

interface

uses Windows, Types, Classes, Controls, Graphics,
  CPPlotCanvas, CPBase, OpenGL_SG, SysUtils, Dialogs, CPOpenGLFont;

{ $DEFINE GLDEBUG}

type
  { Being identical to TColor, this record is used to access the
    single color components (Red, Green, Blue) of it. }
  TColorCh = record
  case Integer of
  0:
    ({ Access whole color value }
     C: TColor);
  1:
    ({ Access red component as byte value }
     R: Byte;
     { Access green component as byte value }
     G: Byte;
     { Access blue component as byte value }
     B: Byte;
     { Access alpha component as byte value }
     A: Byte);
  2:
    ({ Access red component as char value }
     CR: Char;
     { Access green component as char value }
     CG: Char;
     { Access blue component as char value }
     CB: Char;
     { Access alpha component as char value }
     CA: Char);
  end;

  { This class implements GDI painting methods defined by TCPPlotCanvas.
    Canvas units are interpreted as pixels. }
  TCPOpenGLPlotCanvas = class(TCPPlotCanvas)
  private
    function CreateGL: Boolean;
    function FreeGL: Boolean;
    procedure GLClearBG(AColor: TColor);
    procedure MakeCurrent;
    procedure GLSetColor(Color: TColor);
    procedure DrawLine(X1, Y1, X2, Y2: TCPFloat);
  protected
    { Device context of parent }
    DC: HDC;
    { Render context }
    RC: HGLRC;
    QuadObj: PGLUquadric;
    FOpenGLFont: TCPOpenGLFont;
    procedure Resize; override;
    procedure SetBrushColor(const Value: TColor); override;
    procedure FontChanged; override;
    procedure SetPenWidth(const Value: TCPFloat); override;
  public
    { Create the canvas on the referenced parent control.
      @param Control Plotter control) }
    constructor Create(Control: TCustomControl;
      UnitsPerInch: TCPFloat); override;
    destructor Destroy; override;
    procedure DrawLineSegments(Points: TCPFloatArray; Left,
      Right: TCPFloat; StepSize: Double); override;
    function SmoothDistance(Distance: TCPFloat): TCPFloat; override;
    procedure LineTo(X, Y: TCPFloat); override;
    procedure HorizLine(Y: TCPFloat); override;
    procedure VertLine(X: TCPFloat); override;
    procedure Ellipse(const Bounds: TCPBounds); override;
    procedure Rectangle(const Bounds: TCPBounds); override;
    procedure FrameRect(const Bounds: TCPBounds); override;
    procedure FillRect(const Bounds: TCPBounds); override;
    procedure TextOut(X, Y: TCPFloat; const Text: string); override;
    procedure BeginDraw; override;
    procedure EndDraw; override;
  end;

implementation

uses Math;

{ TCPOpenGLPlotCanvas }

procedure PrintError(Context: string);
var
  Error, Index: Integer;
begin
  Index := 0;
  repeat
    Error := glGetError;
    if (Error <> 0) and (Index < 10) then
    begin
      if (Index = 0) then
        Writeln(Context + ' Error:');
      Writeln('  ' + IntToStr(Index + 1) + ': ' + gluErrorString(Error));
      Inc(Index);
    end
    else
      break;
  until false;
end;

procedure TCPOpenGLPlotCanvas.BeginDraw;
begin
  inherited;
  MakeCurrent;
  glLoadIdentity;
  GLClearBG(FColor);
  Resize;
end;

constructor TCPOpenGLPlotCanvas.Create(Control: TCustomControl;
  UnitsPerInch: TCPFloat);
begin
  inherited;
  FOpenGLFont := nil;
  { Opaque flag has to be set to prevent the control from
    drawing a background color, because this is done by
    OpenGL anyway: }
  FControl.ControlStyle := FControl.ControlStyle + [csOpaque];
  { Disable VCL doublebuffering, since OpenGL has its own doublebuffering: }
  FControl.DoubleBuffered := false;
  FMirrorYAxis := true;
  CreateGL;
  { Graphic cards with OpenGL 1.3 support are considered to be capable of
    Anti-Aliasing. It's not really accurate, but it will keep out the crappy
    old cards: }
  FUseDiscreteUnits := not GL_VERSION_1_3;
end;

function TCPOpenGLPlotCanvas.CreateGL: Boolean;
var
  PFD: TPixelFormatDescriptor;
  PixelFormat: TGLint;
begin
  Result := InitOpenGL;
  // Set Pixelformat
  FillChar(pfd, SizeOf(TPixelFormatDescriptor), 0);
  pfd.cColorBits := 32;
  pfd.cDepthBits := 32;
  pfd.dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
  pfd.nSize := SizeOf(TPixelFormatDescriptor);
  pfd.nVersion := 1;
  pfd.iPixelType := PFD_TYPE_RGBA;
  pfd.iLayerType := PFD_MAIN_PLANE;
  DC := Windows.GetDC(FControl.Handle);
  SetLastError(0);
  PixelFormat := ChoosePixelFormat(DC, @pfd);
  if PixelFormat = 0 then
    exit;
  if SetPixelFormat(DC, PixelFormat, @pfd) then
  begin
    RC := wglCreateContext(DC);
    MakeCurrent;
    glClearDepth(1.0);

    glDisable(GL_DITHER);
    glShadeModel(GL_FLAT);
    glDisable(GL_CULL_FACE);

    glAlphaFunc(GL_GREATER,0.0);
    glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);
{    glEnable(GL_LINE_SMOOTH);
    glEnable(GL_POINT_SMOOTH);
    glEnable(GL_POLYGON_SMOOTH);
    glHint(GL_POINT_SMOOTH_HINT, GL_NICEST);
    glHint(GL_LINE_SMOOTH_HINT, GL_NICEST);
    glHint(GL_POLYGON_SMOOTH_HINT, GL_NICEST);}
    glDisable(GL_DEPTH_TEST);
    glDisable(GL_CULL_FACE);
    glMatrixMode(GL_PROJECTION);
    glOrtho(0, FControl.Width, FControl.Height, 0, 0, 0.1);
    glMatrixMode(GL_MODELVIEW);
    glLoadIdentity();
    // Setup Anti-Aliasing:
    if (not FUseDiscreteUnits) then
    begin
      glHint(GL_LINE_SMOOTH_HINT, GL_NICEST);
      glEnable(GL_LINE_SMOOTH);
    end;
    glEnable(GL_BLEND);
    glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
    quadObj := gluNewQuadric;
    Result := true;
    FOpenGLFont := TCPOpenGLFont.Create;
    FOpenGLFont.FirstGlyph := ' ';
    FOpenGLFont.LastGlyph := '?';
    FontChanged;
  end;
end;

destructor TCPOpenGLPlotCanvas.Destroy;
begin
  FOpenGLFont.Free;
  FreeGL;
  inherited;
end;

procedure TCPOpenGLPlotCanvas.DrawLine(X1, Y1, X2, Y2: TCPFloat);
begin
  GLSetColor(FPenColor);
  glBegin(GL_LINES);
  glVertex2d(X1, Y1 + 0.5);
  glVertex2d(X2, Y2 + 0.5);
  glEnd;
end;

procedure TCPOpenGLPlotCanvas.DrawLineSegments(Points: TCPFloatArray; Left,
  Right: TCPFloat; StepSize: Double);
var
  Pt: TCPPoint;
  Index, Count: Integer;
  DrawingLine: Boolean;
begin
  Index := 0;
  DrawingLine := false;
  Pt.X := Left;
  GLSetColor(FPenColor);
  {if (StepSize < 1.0) then
    glLineWidth(PtToUnits(FPenWidth) * (0.5 * (StepSize - 1) + 1));}
  Count := Length(Points);
  while (Index < Count) do
  begin
    Pt.Y := Points[Index];
    if (IsNan(Pt.Y) = false) and
       (IsInfinite(Pt.Y) = false) then
    begin
      if not DrawingLine then
      begin
        glBegin(GL_LINE_STRIP);
        DrawingLine := true;
      end;
      glVertex2d(Pt.X, Pt.Y);
    end
    else
    begin
      // Interrupt line, due to undefined value in definition range:
      if (DrawingLine) then
        glEnd;
      DrawingLine := false;
    end;
    // Move to next graph point:
    Pt.X := Pt.X + StepSize;
    Inc(Index);
  end;
  glEnd;
  //glLineWidth(PtToUnits(FPenWidth));
end;

procedure TCPOpenGLPlotCanvas.Ellipse(const Bounds: TCPBounds);
var
  CtX, CtY: Single;
begin
  CtX := Bounds.Left + Bounds.Width / 2;
  CtY := Bounds.Top + Bounds.Height / 2;
  glPushMatrix();
  glTranslatef (CtX, CtY, 0.0);
  glScaled(Bounds.Width, Bounds.Height, 0);

  gluQuadricDrawStyle(quadObj, GLU_FILL);
  glColor3ub(TColorCh(FBrushColor).R, TColorCh(FBrushColor).G,
    TColorCh(FBrushColor).B);
  gluDisk(QuadObj, 0.0, 0.5, Round((Bounds.Width + Bounds.Height) / 5 + 5), 1);

  gluQuadricDrawStyle(quadObj, GLU_SILHOUETTE);
  glColor3ub(TColorCh(FPenColor).R, TColorCh(FPenColor).G,
    TColorCh(FPenColor).B);
  gluDisk(QuadObj, 0.0, 0.5, Round((Bounds.Width + Bounds.Height) / 5), 1);
  glPopMatrix();
end;

procedure TCPOpenGLPlotCanvas.EndDraw;
begin
  inherited EndDraw;
  glLoadIdentity;
  glFlush();
  SwapBuffers(DC);
end;

procedure TCPOpenGLPlotCanvas.FillRect(const Bounds: TCPBounds);
var
  Right, Bottom: TCPFloat;
begin
  glBegin(GL_QUADS);
  GLSetColor(FBrushColor);
  Right := Bounds.Left + Bounds.Width;
  Bottom := Bounds.Top + Bounds.Height;
  glVertex2d(Bounds.Left, Bottom);
  glVertex2d(Right, Bottom);
  glVertex2d(Right, Bounds.Top);
  glVertex2d(Bounds.Left, Bounds.Top);
  glEnd;
end;

procedure TCPOpenGLPlotCanvas.FrameRect(const Bounds: TCPBounds);
var
  Right, Bottom: TCPFloat;
begin
  glBegin(GL_LINES);
  Right := Bounds.Left + Bounds.Width;
  Bottom := Bounds.Top + Bounds.Height;
  GLSetColor(FBrushColor);
  glVertex2d(Bounds.Left + 0.5, Bottom);
  glVertex2d(Right - 0.5, Bottom);
  glVertex2d(Right - 0.5, Bottom);
  glVertex2d(Right - 0.5, Bounds.Top + 0.5);
  glVertex2d(Right - 0.5, Bounds.Top + 0.5);
  glVertex2d(Bounds.Left + 0.5, Bounds.Top + 0.5);
  glVertex2d(Bounds.Left + 0.5, Bounds.Top + 0.5);
  glVertex2d(Bounds.Left + 0.5, Bottom);
  glEnd;
end;

function TCPOpenGLPlotCanvas.FreeGL: Boolean;
begin
  Result := false;
  if (RC <> 0) then
  begin
    gluDeleteQuadric(quadObj);
    if (not wglMakeCurrent(DC, 0)) then
      raise Exception.Create('FreeGL: Could not deselect active RenderContext!');
    if (not wglDeleteContext(RC)) then
      raise Exception.Create('FreeGL: Could not free RenderContext!');;
    RC := 0;
    Result := true;
  end;
end;

procedure TCPOpenGLPlotCanvas.GLClearBG(AColor: TColor);
begin
  glClearColor(
    TColorCh(AColor).R / 255,
    TColorCh(AColor).G / 255,
    TColorCh(AColor).B / 255, 0);
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
end;

procedure TCPOpenGLPlotCanvas.GLSetColor(Color: TColor);
begin
  glColor3ub(TColorCh(Color).R, TColorCh(Color).G, TColorCh(Color).B);
end;

procedure TCPOpenGLPlotCanvas.HorizLine(Y: TCPFloat);
begin
  DrawLine(0, Y, FBounds.Width, Y);
end;

procedure TCPOpenGLPlotCanvas.LineTo(X, Y: TCPFloat);
begin
  DrawLine(FDrawPos.X, FDrawPos.Y, X, Y);
  FDrawPos := CPToVector(X, Y);
end;

procedure TCPOpenGLPlotCanvas.MakeCurrent;
begin
  if (wglGetCurrentContext() <> RC) or
     (wglGetCurrentDC() <> DC) then
    wglMakeCurrent(DC, RC);
end;

procedure TCPOpenGLPlotCanvas.Rectangle(const Bounds: TCPBounds);
var
  OldBrushColor: TColor;
begin
  FillRect(Bounds);
  OldBrushColor := FBrushColor;
  FBrushColor := FPenColor;
  FrameRect(Bounds);
  FBrushColor := OldBrushColor;
end;

procedure TCPOpenGLPlotCanvas.Resize;
begin
  inherited Resize;
  glViewport(0, 0, Round(FBounds.Width), Round(FBounds.Height));
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  glOrtho(0, FBounds.Width, FBounds.Height, 0.0, 0.0, 1.0);
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
end;

procedure TCPOpenGLPlotCanvas.SetBrushColor(const Value: TColor);
begin
  inherited;
  glColor3ub(TColorCh(FBrushColor).R, TColorCh(FBrushColor).G,
    TColorCh(FBrushColor).B);
end;

procedure TCPOpenGLPlotCanvas.FontChanged;
begin
  inherited;
  FCanvas.Font.Height := -Round(FFontHeight);
  FOpenGLFont.Font := FCanvas.Font;
end;

procedure TCPOpenGLPlotCanvas.SetPenWidth(const Value: TCPFloat);
begin
  inherited;
  glLineWidth(FPenDiscreteUnitWidth);
end;

function TCPOpenGLPlotCanvas.SmoothDistance(Distance: TCPFloat): TCPFloat;
begin
  Result := Round(Distance);
end;

procedure TCPOpenGLPlotCanvas.TextOut(X, Y: TCPFloat; const Text: string);
begin
  glEnable(GL_TEXTURE_2D);
  FOpenGLFont.DrawText(Round(X), Round(Y), Text, FPenColor);
  glDisable(GL_TEXTURE_2D);
end;

procedure TCPOpenGLPlotCanvas.VertLine(X: TCPFloat);
begin
  DrawLine(X, 0, X, FBounds.Height);
end;

initialization
end.
